{-
 This file is part of the Clafer to Alloy Translator (clafer2alloy).

 Copyright (C) 2010 Kacper Bak <http://gsd.uwaterloo.ca/kbak>

 clafer2alloy is free software: you can redistribute it and/or modify
 it under the terms of the GNU Lesser General Public License as published by
 the Free Software Foundation, either version 3 of the License, or
 (at your option) any later version.

 clafer2alloy is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU Lesser General Public License for more details.

 You should have received a copy of the GNU Lesser General Public License
 along with clafer2alloy. (See files COPYING and COPYING.LESSER.)  If not,
 see <http://www.gnu.org/licenses/>.
-}
-- IMPORTANT: super quick & dirty solution
module Xmlclafer2alloy where

import Absclafer2alloy
import Common

tag name exp = concat ["<", name, ">", exp, "</", name, ">"]

clafer2xml mod = putStrLn $ clafer2xmlModule mod

clafer2xmlModule :: Module -> Result
clafer2xmlModule x = case x of
  Module declarations  -> concat
    [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
    , tag "Module" $ declarations >>= clafer2xmlDeclaration]
   
clafer2xmlDeclaration :: Declaration -> Result
clafer2xmlDeclaration x = case x of
  EnumDecl id enumids  -> error "desugared"
  AbsClaferDecl gcard ident super attr elements  -> 
      tag "AbsClaferDecl" $ concat [ clafer2xmlGCard gcard
                                   , clafer2xmlIdent ident
                                   , clafer2xmlSuper super
                                   , clafer2xmlAttr attr
                                   , clafer2xmlElements elements]
  ClaferDecl clafer  -> tag "ClaferDecl" $ clafer2xmlClafer clafer
  ConstDecl constraint  -> tag "ConstDecl" $ clafer2xmlConstraint constraint

clafer2xmlConstraint :: Constraint -> Result
clafer2xmlConstraint x = case x of
  Constraint essential lexps  ->
      tag "Constraint" $ concat [ clafer2xmlEssential essential
                                , lexps >>= clafer2xmlLExp]

clafer2xmlClafer :: Clafer -> Result
clafer2xmlClafer x = case x of
  Clafer gcard ident super attr essential card elements  -> 
      tag "Clafer" $ concat [ clafer2xmlGCard gcard
                            , clafer2xmlIdent ident
                            , clafer2xmlSuper super
                            , clafer2xmlAttr attr
                            , clafer2xmlEssential essential
                            , clafer2xmlCard card
                            , clafer2xmlElements elements]

clafer2xmlElements :: Elements -> Result
clafer2xmlElements x = case x of
  ElementsEmpty  -> error "desugared"
  Elements elements  -> tag "Elements" $ elements >>= clafer2xmlElement

clafer2xmlElement :: Element -> Result
clafer2xmlElement x = case x of
  Subclafer clafer  -> tag "Subclafer" $ clafer2xmlClafer clafer
  ClaferUse name essential card elements -> error "desugared"
  Subconstraint constraint  -> tag "Subconstraint" $ clafer2xmlConstraint constraint

clafer2xmlEssential :: Essential -> Result
clafer2xmlEssential x = case x of
  EssentialEmpty  -> tag "EssentialEmpty" ""
  Essential  -> tag "Essential" ""

clafer2xmlSuper :: Super -> Result
clafer2xmlSuper x = case x of
  SuperEmpty  -> error "desugared"
  Super name  -> tag "Super" $ clafer2xmlName name

clafer2xmlAttr :: Attr -> Result
clafer2xmlAttr x = case x of
  AttrEmpty  -> tag "AttrEmpty" ""
  AttrSExp modids sexp  ->
      tag "AttrSExp" $ concat [ modids >>= clafer2xmlModId
                              , clafer2xmlSExp sexp]
  AttrSuper modids sexp ->
      tag "AttrSuper" $ concat [ modids >>= clafer2xmlModId
                               , clafer2xmlSExp sexp]

clafer2xmlGCard :: GCard -> Result
clafer2xmlGCard x = case x of
  GCardEmpty  -> tag "GCardEmpty" ""
  GCardXor  -> error "desugared"
  GCardOr   -> error "desugared"
  GCardMux  -> error "desugared"
  GCardInterval (GNCard m n)  ->
      tag "GCardInterval" $ tag "GNCard" $ concat [ clafer2xmlInteger m
                                                  , clafer2xmlExInteger n]

clafer2xmlCard :: Card -> Result
clafer2xmlCard x = case x of
  CardEmpty  -> error "desugared"
  CardLone  -> error "desugared"
  CardSome  -> error "desugared"
  CardAny  -> error "desugared"
  CardInterval (NCard m n)  ->
      tag "CardInterval" $ tag "NCard" $ concat [ clafer2xmlInteger m
                                                , clafer2xmlExInteger n]

clafer2xmlInteger :: Integer -> Result
clafer2xmlInteger n = tag "Integer" $ show n

clafer2xmlString :: String -> Result
clafer2xmlString str = tag "String" str'
  where
  str' = case str of
    ('@':ss) -> ss
    _        -> str

clafer2xmlBool :: Bool -> Result
clafer2xmlBool True = tag "Bool" "True"
clafer2xmlBool False = tag "Bool" "False"

clafer2xmlExInteger :: ExInteger -> Result
clafer2xmlExInteger x = case x of
  ExIntegerAst  -> tag "ExIntegerAst" ""
  ExIntegerNum n  -> tag "ExIntegerNum" $ clafer2xmlInteger n

clafer2xmlSExp :: SExp -> Result
clafer2xmlSExp x = case x of
  SExpUnion sexp0 sexp -> clafer2xmlS "SExpUnion" sexp0 sexp
  SExpIntersection sexp0 sexp  -> clafer2xmlS "SExpIntersection" sexp0 sexp
  SExpDomain sexp0 sexp  -> clafer2xmlS "SExpDomain" sexp0 sexp
  SExpRange sexp0 sexp  -> clafer2xmlS "SExpRange" sexp0 sexp
  SExpJoin sexp0 sexp  -> clafer2xmlS "SExpJoin" sexp0 sexp
  SExpArrow sexp0 sexp  -> error "desugared"
  SExpRIdent ident b -> tag "SExpRIdent" $ concat [ clafer2xmlIdent ident
                                                  , clafer2xmlBool b]
  where
  clafer2xmlS t e1 e2 = clafer2xmlBinOp t clafer2xmlSExp e1 e2

clafer2xmlBinOp t f e1 e2 = tag t $ concat [f e1, f e2]

clafer2xmlLExp :: LExp -> Result
clafer2xmlLExp x = case x of
  EIff lexp0 iff lexp  -> clafer2xmlL "EIff" lexp0 lexp
  EImplies lexp0 implies lexp  -> clafer2xmlL "EImplies" lexp0 lexp
  EImpliesElse lexp0 implies lexp1 lexp  ->
      tag "EImpliesElse" $ [lexp0, lexp1, lexp] >>= clafer2xmlLExp
  EOr lexp0 or lexp  -> clafer2xmlL "EOr" lexp0 lexp
  EXor lexp0 xor lexp  -> clafer2xmlL "EXor" lexp0 lexp
  EAnd lexp0 and lexp  -> clafer2xmlL "EAnd" lexp0 lexp
  ENeg neg lexp  -> tag "ENeg" $ clafer2xmlLExp lexp
  ETerm term  -> tag "ETerm" $ clafer2xmlTerm term
  where
  clafer2xmlL t e1 e2 = clafer2xmlBinOp t clafer2xmlLExp e1 e2

clafer2xmlTerm :: Term -> Result
clafer2xmlTerm x = case x of
  TermCmpExp cmpexp  -> tag "TermCmpExp" $ clafer2xmlCmpExp cmpexp
  TermSet sexp        -> error "desugared"
  TermQuantSet quant sexp ->
      tag "TermQuantSet" $ concat [ clafer2xmlQuant quant
                                  , clafer2xmlSExp sexp]
  TermQuantDeclExp decls lexp ->
      tag "TermQuantDeclExp" $ concat [ decls >>= clafer2xmlDecl
                                      , clafer2xmlLExp lexp]

clafer2xmlCmpExp :: CmpExp -> Result
clafer2xmlCmpExp x = case x of
  ELt exp0 exp  -> clafer2xmlCmp "ELt" exp0 exp
  EGt exp0 exp  -> clafer2xmlCmp "EGt" exp0 exp
  EEq exp0 exp  -> clafer2xmlCmp "EEq" exp0 exp
  EREq exp0 exp  -> clafer2xmlCmp "EREq" exp0 exp
  ELte exp0 exp  -> clafer2xmlCmp "ELte" exp0 exp
  EGte exp0 exp  -> clafer2xmlCmp "EGte" exp0 exp
  ENeq exp0 exp  -> clafer2xmlCmp "ENeq" exp0 exp
  ERNeq exp0 exp  -> clafer2xmlCmp "ERNeq" exp0 exp
  EIn exp0 exp  -> clafer2xmlCmp "EIn" exp0 exp
  ENin exp0 exp  -> clafer2xmlCmp "ENin" exp0 exp
  where
  clafer2xmlCmp t e1 e2 = clafer2xmlBinOp t clafer2xmlExp e1 e2


clafer2xmlExp :: Exp -> Result
clafer2xmlExp x = case x of
  ESetExp sexp  -> tag "ESetExp" $ clafer2xmlSExp sexp
  ENumExp aexp -> tag "ENumExp" $ clafer2xmlAExp aexp
  EStrExp strexp -> error "analyzed"


clafer2xmlQuant :: Quant -> Result
clafer2xmlQuant x = case x of
  QuantNo   -> tag "QuantNo" ""
  QuantLone -> tag "QuantLone" ""
  QuantOne  -> tag "QuantOne" ""
  QuantSome -> tag "QuantSome" ""


clafer2xmlExQuant :: ExQuant -> Result
clafer2xmlExQuant x = case x of
  ExQuantAll -> tag "ExQuantAll" ""
  ExQuant quant -> tag "ExQuant" $ clafer2xmlQuant quant


clafer2xmlDecl :: Decl -> Result
clafer2xmlDecl x = case x of
  Decl exquant disj locids sexp -> 
      tag "Decl" $ concat [ clafer2xmlExQuant exquant
                          , clafer2xmlDisj disj
                          , locids >>= clafer2xmlLocId
                          , clafer2xmlSExp sexp]

clafer2xmlDisj :: Disj -> Result
clafer2xmlDisj x = case x of
  DisjEmpty -> tag "DisjEmpty" ""
  Disj -> tag "Disj" ""

clafer2xmlLocId :: LocId -> Result
clafer2xmlLocId x = case x of
   LocIdIdent ident -> tag "LocIdIdent" $ clafer2xmlIdent ident


clafer2xmlAExp :: AExp -> Result
clafer2xmlAExp x = case x of
  EAdd aexp0 aexp -> clafer2xmlArith "EAdd" aexp0 aexp
  ESub aexp0 aexp -> clafer2xmlArith "ESub" aexp0 aexp
  EMul aexp0 aexp -> clafer2xmlArith "EMul" aexp0 aexp
  EUmn aexp -> tag "EUmn" $ clafer2xmlAExp aexp
  ECSetExp sexp -> tag "ECSetExp" $ clafer2xmlSExp sexp
  EInt n    -> tag "EInt" $ clafer2xmlInteger n
  where
  clafer2xmlArith t e1 e2 = clafer2xmlBinOp t clafer2xmlAExp e1 e2

clafer2xmlIdent :: Ident -> Result
clafer2xmlIdent x = case x of
  Ident str  -> tag "Ident" $ clafer2xmlString str


clafer2xmlName :: Name -> Result
clafer2xmlName x = case x of
  Name modids id  -> tag "Name" $ concat [ modids >>= clafer2xmlModId
                                         , clafer2xmlIdent id]

clafer2xmlModId :: ModId -> Result
clafer2xmlModId x = case x of
  ModIdIdent id  -> tag "ModIdIdent" $ clafer2xmlIdent id


{-
clafer2xml mod = do
  runX ( constA mod
         >>>
	 xpickleDocument xpModule [(a_indent, v_1)] "-"
       )
  return ()

xpModule :: PU Module
xpModule = xpickle

instance XmlPickler Module where
  xpickle = xpAlt tag ps
    where
    tag (Module _) = 0
    ps = [ xpWrap ( Module
                  , \ (Module declarations) -> declarations )
                  ( xpElem "Module" $
                    xpList xpickle)
         ] 

instance XmlPickler Declaration where
  xpickle = xpAlt tag ps
    where
    tag (AbsClaferDecl _ _ _ _ _) = 0
    tag (ClaferDecl _)            = 1
    tag (ConstDecl _)             = 2
    ps = [ xpWrap  ( uncurry5 $ AbsClaferDecl
                   , \ (AbsClaferDecl gcard ident super attr elements) ->
                       (gcard, ident, super, attr, elements))
                   ( xpElem "AbsClaferDecl" $
                     xp5Tuple xpickle xpickle xpickle xpickle xpickle)
         , xpWrap ( ClaferDecl
                  , \ (ClaferDecl clafer) -> clafer)
                  ( xpElem "ClaferDecl" $
                    xpickle)
         , xpWrap ( ConstDecl
                  , \ (ConstDecl constraint) -> constraint )
                  ( xpElem "ConstDecl" $
                    xpickle)
         ]

instance XmlPickler Constraint where
  xpickle = xpAlt tag ps
    where
    tag (Constraint _ _ ) = 0
    ps = [ xpWrap ( uncurry Constraint
                  , \ (Constraint essential lexps) -> (essential, lexps))
                  ( xpElem "Constraint" $ 
                    xpPair xpickle (xpList xpickle))
         ]

instance XmlPickler Clafer where
  xpickle = xpAlt tag ps
    where
    tag (Clafer _ _ _ _ _ _ _) = 0
    ps = [ xpWrap  ( uncurry7 $ Clafer
                   , \ (Clafer gcard ident super attr essential card elements) ->
                       (gcard, ident, super, attr, essential, card, elements))
                   ( xpElem "Clafer" $
                     xp7Tuple xpickle xpickle xpickle xpickle xpickle xpickle xpickle)
         ]

    
instance XmlPickler Elements where
  xpickle = xpAlt tag ps
    where
    tag (Elements _) = 0
    ps = [ xpWrap ( Elements
                  , \ (Elements elements) -> elements )
                  ( xpElem "Elements" $
                    xpList xpickle)
         ]

instance XmlPickler Element where
  xpickle = xpAlt tag ps
    where
    tag (Subclafer _) = 0
    tag (Subconstraint _) = 1
    ps = [ xpWrap ( Subclafer
                  , \(Subclafer clafer) -> clafer )
                  ( xpElem "Subclafer" $ xpickle)
         , xpWrap ( Subconstraint
                  , \(Subconstraint constraint) -> constraint )
                  ( xpElem "Subconstraint" $ xpickle)
         ]

instance XmlPickler Essential where
  xpickle = xpPrim

instance XmlPickler Super where
  xpickle = xpAlt tag ps
    where
    tag (Super _) = 0
    ps = [ xpWrap ( Super
                  , \(Super name) -> name )
                  ( xpElem "Super" $ xpickle)
         ]

instance XmlPickler Attr where
  xpickle = xpAlt tag ps
    where
    tag AttrEmpty = 0
    tag (AttrSExp _ _) = 1
    tag (AttrSuper _ _) = 2
    ps = [ xpPrim
          , xpWrap ( uncurry AttrSExp
                   , \ (AttrSExp modids sexp) -> (modids, sexp))
                   ( xpElem "AttrSExp" $ 
                     xpPair xpickle xpickle)
          , xpWrap ( uncurry AttrSExp
                   , \ (AttrSuper modids sexp) -> (modids, sexp))
                   ( xpElem "AttrSuper" $ 
                     xpPair xpickle xpickle)
          ]

instance XmlPickler GCard where
  xpickle = xpAlt tag ps
    where
    tag (GCardInterval _) = 0
    ps = [ xpWrap ( GCardInterval
                  , \(GCardInterval interval) -> interval )
                  ( xpElem "GCardInterval" $ xpickle )
         ]

instance XmlPickler GNCard where
  xpickle = xpAlt tag ps
    where
    tag (GNCard _ _) = 0
    ps = [ xpWrap ( uncurry GNCard
                  , \(GNCard m n) -> (m, n) )
                  ( xpElem "GNCard" $ xpPair xpickle xpickle )
         ]

instance XmlPickler Card where
  xpickle = xpAlt tag ps
    where
    tag (CardInterval _) = 0
    ps = [ xpWrap ( CardInterval
                  , \(CardInterval interval) -> interval )
                  ( xpElem "CardInterval" $ xpickle )
         ]

instance XmlPickler NCard where
  xpickle = xpAlt tag ps
    where
    tag (NCard _ _) = 0
    ps = [ xpWrap ( uncurry NCard
                  , \(NCard m n) -> (m, n) )
                  ( xpElem "NCard" $ xpPair xpickle xpickle )
         ]

instance XmlPickler ExInteger where
  xpickle = xpAlt tag ps
    where
    tag ExIntegerAst = 0
    tag (ExIntegerNum _) = 1
    ps = [ xpPrim
         , xpWrap ( ExIntegerNum
                  , \(ExIntegerNum n) -> n )
                  ( xpElem "ExIntegerNum" $ xpickle )
         ]

instance XmlPickler SExp where
  xpickle = xpAlt tag ps
    where
    tag (SExpUnion _ _) = 0
    tag (SExpIntersection _ _) = 1
    tag (SExpDomain _ _) = 2
    tag (SExpRange _ _) = 3
    tag (SExpJoin _ _) = 4
    tag (SExpArrow _ _) = 5
    tag (SExpRIdent _ _) = 6
    ps = [ xpWrap ( uncurry SExpUnion
                  , \(SExpUnion sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "SExpUnion" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry SExpIntersection
                  , \(SExpIntersection sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "SExpIntersection" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry SExpDomain
                  , \(SExpDomain sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "SExpDomain" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry SExpRange
                  , \(SExpRange sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "SExpRange" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry SExpJoin
                  , \(SExpJoin sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "SExpJoin" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry SExpArrow
                  , \(SExpArrow sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "SExpArrow" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry SExpRIdent
                  , \(SExpRIdent sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "SExpRIdent" $ xpPair xpickle xpPrim )         
         ]

instance XmlPickler LExp where
  xpickle = xpAlt tag ps
    where
    tag (EIff _ _ _) = 0
    tag (EImplies _ _ _) = 1
    tag (EImpliesElse _ _ _ _) = 2
    tag (EOr _ _ _) = 3
    tag (EXor _ _ _) = 4
    tag (EAnd _ _ _) = 5
    tag (ENeg _ _) = 6
    tag (ETerm _) = 7
    ps = [ xpWrap ( uncurry3 $ EIff
                  , \(EIff lexp0 op lexp) -> (lexp0, op, lexp) )
                  ( xpElem "EIff" $ xpTriple xpickle xpickle xpickle )
         , xpWrap ( uncurry3 $ EImplies
                  , \(EImplies lexp0 op lexp) -> (lexp0, op, lexp) )
                  ( xpElem "EImplies" $ xpTriple xpickle xpickle xpickle )
         , xpWrap ( uncurry4 $ EImpliesElse
                  , \(EImpliesElse lexp0 op lexp1 lexp) -> (lexp0, op, lexp1, lexp) )
                  ( xpElem "EImpliesElse" $ xp4Tuple xpickle xpickle xpickle xpickle )
         , xpWrap ( uncurry3 $ EOr
                  , \(EOr lexp0 op lexp) -> (lexp0, op, lexp) )
                  ( xpElem "EOr" $ xpTriple xpickle xpickle xpickle )
         , xpWrap ( uncurry3 EXor
                  , \(EXor lexp0 op lexp) -> (lexp0, op, lexp) )
                  ( xpElem "EXor" $ xpTriple xpickle xpickle xpickle )
         , xpWrap ( uncurry3 $ EAnd
                  , \(EAnd lexp0 op lexp) -> (lexp0, op, lexp) )
                  ( xpElem "EAnd" $ xpTriple xpickle xpickle xpickle )
         , xpWrap ( uncurry ENeg
                  , \(ENeg neg lexp) -> (neg, lexp) )
                  ( xpElem "ENeg" $ xpPair xpickle xpickle )
         , xpWrap ( ETerm
                  , \(ETerm lexp) -> lexp )
                  ( xpElem "ETerm" $ xpickle )
         ]

instance XmlPickler Iff where
  xpickle = xpPrim

instance XmlPickler Implies where
  xpickle = xpPrim

instance XmlPickler And where
  xpickle = xpPrim

instance XmlPickler Or where
  xpickle = xpPrim

instance XmlPickler Xor where
  xpickle = xpPrim

instance XmlPickler Neg where
  xpickle = xpPrim

instance XmlPickler Term where
  xpickle = xpAlt tag ps
    where
    tag (TermCmpExp _) = 0
    tag (TermQuantSet _ _) = 1
    tag (TermQuantDeclExp _ _) = 2
    ps = [ xpWrap ( TermCmpExp
                  , \(TermCmpExp cmpexp) -> cmpexp )
                  ( xpElem "TermCmpExp" $ xpickle )
         , xpWrap ( uncurry TermQuantSet
                  , \(TermQuantSet quant sexp) -> (quant, sexp) )
                  ( xpElem "TermQuantSet" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry TermQuantDeclExp
                  , \(TermQuantDeclExp decls lexp) -> (decls, lexp) )
                  ( xpElem "TermQuantDeclExp" $ xpPair xpickle xpickle )
         ]

instance XmlPickler CmpExp where
  xpickle = xpAlt tag ps
    where
    tag (ELt _ _) = 0
    tag (EGt _ _) = 1
    tag (EEq _ _) = 2
    tag (EREq _ _) = 3
    tag (ELte _ _) = 4
    tag (EGte _ _) = 5
    tag (ENeq _ _) = 6
    tag (ERNeq _ _) = 7
    tag (EIn _ _) = 8
    tag (ENin _ _) = 9
    ps = [ xpWrap ( uncurry ELt
                  , \(ELt sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "ELt" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry EGt
                  , \(EGt sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "EGt" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry EEq
                  , \(EEq sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "EEq" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry EREq
                  , \(EREq sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "EREq" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry ELte
                  , \(ELte sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "ELte" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry EGte
                  , \(EGte sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "EGte" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry ENeq
                  , \(ENeq sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "ENeq" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry ERNeq
                  , \(ERNeq sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "ERNeq" $ xpPair xpickle xpickle )         
         , xpWrap ( uncurry EIn
                  , \(EIn sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "EIn" $ xpPair xpickle xpickle )         
         , xpWrap ( uncurry ENin
                  , \(ENin sexp0 sexp) -> (sexp0, sexp) )
                  ( xpElem "ENin" $ xpPair xpickle xpickle )         
         ]

instance XmlPickler Exp where
  xpickle = xpAlt tag ps
    where
    tag (ESetExp _) = 0
    tag (ENumExp _) = 1
    tag (EStrExp _) = 2
    ps = [ xpWrap ( ESetExp
                  , \(ESetExp exp) -> exp )
                  ( xpElem "ESetExp" $ xpickle )
         , xpWrap ( ENumExp
                  , \(ENumExp exp) -> exp )
                  ( xpElem "ENumExp" $ xpickle )
         , xpWrap ( EStrExp
                  , \(EStrExp exp) -> exp )
                  ( xpElem "EStrExp" $ xpickle )
         ]

instance XmlPickler Quant where
  xpickle = xpPrim

instance XmlPickler ExQuant where
  xpickle = xpAlt tag ps
    where
    tag ExQuantAll = 0
    tag (ExQuant _) = 1
    ps = [ xpPrim
         , xpWrap ( ExQuant
                  , \(ExQuant quant) -> quant )
                  ( xpElem "ExQuant" $ xpickle )
         ]

instance XmlPickler Decl where
  xpickle = xpAlt tag ps
    where
    tag (Decl _ _ _ _) = 0
    ps = [ xpWrap ( uncurry4 $ Decl
                  , \(Decl exquant disj locids sexp) -> (exquant, disj, locids, sexp))
                  ( xpElem "Decl" $ xp4Tuple xpickle xpickle xpickle xpickle)
         ]

instance XmlPickler Disj where
  xpickle = xpPrim

instance XmlPickler LocId where
  xpickle = xpAlt tag ps
    where
    tag (LocIdIdent _) = 0
    ps = [ xpWrap ( LocIdIdent
                  , \(LocIdIdent ident) -> ident )
                  ( xpElem "LocIdIdent" $ xpickle )
         ]

instance XmlPickler AExp where
  xpickle = xpAlt tag ps
    where
    tag (EAdd _ _) = 0
    tag (ESub _ _) = 1
    tag (EMul _ _) = 2
    tag (EUmn _) = 3
    tag (ECSetExp _) = 4
    tag (EInt _) = 5
    ps = [ xpWrap ( uncurry EAdd
                  , \(EAdd aexp0 aexp) -> (aexp0, aexp) )
                  ( xpElem "EAdd" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry ESub
                  , \(ESub aexp0 aexp) -> (aexp0, aexp) )
                  ( xpElem "ESub" $ xpPair xpickle xpickle )
         , xpWrap ( uncurry EMul
                  , \(EMul aexp0 aexp) -> (aexp0, aexp) )
                  ( xpElem "EMul" $ xpPair xpickle xpickle )
         , xpWrap ( EUmn
                  , \(EUmn aexp) -> aexp )
                  ( xpElem "EUmn" $ xpickle )
         , xpWrap ( ECSetExp
                  , \(ECSetExp sexp) -> sexp )
                  ( xpElem "ECSetExp" $ xpickle )
         , xpWrap ( EInt
                  , \(EInt n) -> n )
                  ( xpElem "EInt" $ xpickle )
         ]

instance XmlPickler Ident where
  xpickle = xpAlt tag ps
    where
    tag (Ident _) = 0
    ps = [ xpWrap ( Ident
                  , \(Ident ident) -> ident )
                  ( xpElem "Ident" $ xpText )
         ]

instance XmlPickler Name where
  xpickle = xpAlt tag ps
    where
    tag (Name _ _) = 0
    ps = [ xpWrap ( uncurry Name
                  , \(Name modids id) -> (modids, id))
                  ( xpElem "Name" $ xpPair (xpList xpickle) xpickle )
         ]

instance XmlPickler EnumId where
  xpickle = xpAlt tag ps
    where
    tag (EnumIdIdent _) = 0
    ps = [ xpWrap ( EnumIdIdent
                  , \(EnumIdIdent ident) -> ident )
                  ( xpElem "EnumIdIdent" $ xpickle )
         ]

instance XmlPickler ModId where
  xpickle = xpAlt tag ps
    where
    tag (ModIdIdent _) = 0
    ps = [ xpWrap ( ModIdIdent
                  , \(ModIdIdent ident) -> ident )
                  ( xpElem "ModIdIdent" $ xpickle )
         ]

instance XmlPickler StrExp where
  xpickle = xpAlt tag ps
    where
    tag (EStr _) = 0
    ps = [ xpWrap ( EStr
                  , \(EStr str) -> str )
                  ( xpElem "EStr" $ xpText )
         ]
-}